home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / threads.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  4.0 KB  |  118 lines
  1. ;;;;     Copyright (C) 1996, 1998, 2001 Free Software Foundation, Inc.
  2. ;;;;
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;;
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; As a special exception, the Free Software Foundation gives permission
  19. ;;;; for additional uses of the text contained in its release of GUILE.
  20. ;;;;
  21. ;;;; The exception is that, if you link the GUILE library with other files
  22. ;;;; to produce an executable, this does not by itself cause the
  23. ;;;; resulting executable to be covered by the GNU General Public License.
  24. ;;;; Your use of that executable is in no way restricted on account of
  25. ;;;; linking the GUILE library code into it.
  26. ;;;;
  27. ;;;; This exception does not however invalidate any other reasons why
  28. ;;;; the executable file might be covered by the GNU General Public License.
  29. ;;;;
  30. ;;;; This exception applies only to the code released by the
  31. ;;;; Free Software Foundation under the name GUILE.  If you copy
  32. ;;;; code from other Free Software Foundation releases into a copy of
  33. ;;;; GUILE, as the General Public License permits, the exception does
  34. ;;;; not apply to the code that you add in this way.  To avoid misleading
  35. ;;;; anyone as to the status of such modified files, you must delete
  36. ;;;; this exception notice from them.
  37. ;;;;
  38. ;;;; If you write modifications of your own for GUILE, it is your choice
  39. ;;;; whether to permit this exception to apply to your modifications.
  40. ;;;; If you do not wish that, delete this exception notice.
  41. ;;;;
  42. ;;;; ----------------------------------------------------------------
  43. ;;;; threads.scm -- User-level interface to Guile's thread system
  44. ;;;; 4 March 1996, Anthony Green <green@cygnus.com>
  45. ;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
  46. ;;;; Modified 6 April 2001, ttn
  47. ;;;; ----------------------------------------------------------------
  48. ;;;;
  49.  
  50. ;;; Commentary:
  51.  
  52. ;; This module is documented in the Guile Reference Manual.
  53. ;; Briefly, one procedure is exported: `%thread-handler';
  54. ;; as well as four macros: `make-thread', `begin-thread',
  55. ;; `with-mutex' and `monitor'.
  56.  
  57. ;;; Code:
  58.  
  59. (define-module (ice-9 threads)
  60.   :export-syntax (make-thread
  61.           begin-thread
  62.           with-mutex
  63.           monitor)
  64.   :export (%thread-handler))
  65.  
  66.  
  67.  
  68. (define (%thread-handler tag . args)
  69.   (fluid-set! the-last-stack #f)
  70.   (unmask-signals)
  71.   (let ((n (length args))
  72.     (p (current-error-port)))
  73.     (display "In thread:" p)
  74.     (newline p)
  75.     (if (>= n 3)
  76.         (display-error #f
  77.                        p
  78.                        (car args)
  79.                        (cadr args)
  80.                        (caddr args)
  81.                        (if (= n 4)
  82.                            (cadddr args)
  83.                            '()))
  84.         (begin
  85.           (display "uncaught throw to " p)
  86.           (display tag p)
  87.           (display ": " p)
  88.           (display args p)
  89.           (newline p)))))
  90.  
  91. ; --- MACROS -------------------------------------------------------
  92.  
  93. (defmacro make-thread (proc . args)
  94.   `(call-with-new-thread
  95.     (lambda ()
  96.       (,proc ,@args))
  97.     %thread-handler))
  98.  
  99. (defmacro begin-thread (first . rest)
  100.   `(call-with-new-thread
  101.     (lambda ()
  102.       (begin
  103.     ,first ,@rest))
  104.     %thread-handler))
  105.  
  106. (defmacro with-mutex (m . body)
  107.   `(dynamic-wind
  108.        (lambda () (lock-mutex ,m))
  109.        (lambda () (begin ,@body))
  110.        (lambda () (unlock-mutex ,m))))
  111.  
  112. (defmacro monitor (first . rest)
  113.   `(with-mutex ,(make-mutex)
  114.      (begin
  115.        ,first ,@rest)))
  116.  
  117. ;;; threads.scm ends here
  118.